home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / srcuc.zip / DEBUG.C < prev    next >
Encoding:
C/C++ Source or Header  |  1992-02-04  |  25.7 KB  |  1,029 lines
  1. /* -*-C-*-
  2.  
  3. $Header: /scheme/src/microcode/RCS/debug.c,v 9.43 1992/02/04 04:14:43 jinx Exp cph $
  4.  
  5. Copyright (c) 1987-1992 Massachusetts Institute of Technology
  6.  
  7. This material was developed by the Scheme project at the Massachusetts
  8. Institute of Technology, Department of Electrical Engineering and
  9. Computer Science.  Permission to copy this software, to redistribute
  10. it, and to use it for any purpose is granted, subject to the following
  11. restrictions and understandings.
  12.  
  13. 1. Any copy made of this software must include this copyright notice
  14. in full.
  15.  
  16. 2. Users of this software agree to make their best efforts (a) to
  17. return to the MIT Scheme project any improvements or extensions that
  18. they make, so that these may be included in future releases; and (b)
  19. to inform MIT of noteworthy uses of this software.
  20.  
  21. 3. All materials developed as a consequence of the use of this
  22. software shall duly acknowledge such use, in accordance with the usual
  23. standards of acknowledging credit in academic research.
  24.  
  25. 4. MIT has made no warrantee or representation that the operation of
  26. this software will be error-free, and MIT is under no obligation to
  27. provide any services, by way of maintenance, update, or otherwise.
  28.  
  29. 5. In conjunction with products arising from the use of this material,
  30. there shall be no use of the name of the Massachusetts Institute of
  31. Technology nor of any adaptation thereof in any advertising,
  32. promotional, or sales literature without prior written consent from
  33. MIT in each case. */
  34.  
  35. /* Utilities to help with debugging */
  36.  
  37. #include "scheme.h"
  38. #include "prims.h"
  39. #include "trap.h"
  40. #include "lookup.h"
  41.  
  42. static void EXFUN (do_printing, (FILE *, SCHEME_OBJECT, Boolean));
  43. static Boolean EXFUN (print_primitive_name, (FILE *, SCHEME_OBJECT));
  44. static void EXFUN (print_expression, (FILE *, SCHEME_OBJECT, char *));
  45.  
  46. /* Compiled Code Debugging */
  47.  
  48. static SCHEME_OBJECT
  49. DEFUN (compiled_block_debug_filename, (block), SCHEME_OBJECT block)
  50. {
  51.   extern SCHEME_OBJECT EXFUN (compiled_block_debugging_info, (SCHEME_OBJECT));
  52.   SCHEME_OBJECT info;
  53.  
  54.   info = (compiled_block_debugging_info (block));
  55.   return
  56.     (((STRING_P (info)) ||
  57.       ((PAIR_P (info)) &&
  58.        (STRING_P (PAIR_CAR (info))) &&
  59.        (FIXNUM_P (PAIR_CDR (info)))))
  60.      ? info
  61.      : SHARP_F);
  62. }
  63.  
  64. extern void
  65.   EXFUN (compiled_entry_type, (SCHEME_OBJECT, long *));
  66.  
  67. extern long
  68.   EXFUN (compiled_entry_closure_p, (SCHEME_OBJECT)),
  69.   EXFUN (compiled_entry_to_block_offset, (SCHEME_OBJECT));
  70.  
  71. extern SCHEME_OBJECT
  72.   * EXFUN (compiled_entry_to_block_address, (SCHEME_OBJECT)),
  73.   EXFUN (compiled_closure_to_entry, (SCHEME_OBJECT));
  74.  
  75. #define COMPILED_ENTRY_TO_BLOCK(entry)                    \
  76. (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK,                \
  77.               (compiled_entry_to_block_address (entry))))
  78.  
  79. static SCHEME_OBJECT
  80. DEFUN (compiled_entry_debug_filename, (entry), SCHEME_OBJECT entry)
  81. {
  82.   long results [3];
  83.  
  84.   compiled_entry_type (entry, (& (results [0])));
  85.   if (((results [0]) == 0) && (compiled_entry_closure_p (entry)))
  86.     entry = (compiled_closure_to_entry (entry));
  87.   return (compiled_block_debug_filename (COMPILED_ENTRY_TO_BLOCK (entry)));
  88. }
  89.  
  90. char *
  91. DEFUN (compiled_entry_filename, (entry), SCHEME_OBJECT entry)
  92. {
  93.   SCHEME_OBJECT result;
  94.  
  95.   result = (compiled_entry_debug_filename (entry));
  96.   if (STRING_P (result))
  97.     return ((char *) (STRING_LOC ((result), 0)));
  98.   else if (PAIR_P (result))
  99.     return ((char *) (STRING_LOC ((PAIR_CAR (result)), 0)));
  100.   else
  101.     return ("**** filename not known ****");
  102. }
  103.  
  104. void
  105. DEFUN_VOID (Show_Pure)
  106. {
  107.   SCHEME_OBJECT *Obj_Address;
  108.   long Pure_Size, Total_Size;
  109.  
  110.   Obj_Address = Constant_Space;
  111.   while (true)
  112.   {
  113.     if (Obj_Address > Free_Constant)
  114.     {
  115.       printf ("Past end of area.\n");
  116.       return;
  117.     }
  118.     if (Obj_Address == Free_Constant)
  119.     {
  120.       printf ("Done.\n");
  121.       return;
  122.     }
  123.     Pure_Size = OBJECT_DATUM (*Obj_Address);
  124.     Total_Size = OBJECT_DATUM (Obj_Address[1]);
  125.     printf ("0x%lx: pure=0x%lx, total=0x%lx\n",
  126.         ((long) Obj_Address), ((long) Pure_Size), ((long) Total_Size));
  127.     if (OBJECT_TYPE (*Obj_Address) != TC_MANIFEST_SPECIAL_NM_VECTOR)
  128.     {
  129.       printf ("Missing initial SNMV.\n");
  130.       return;
  131.     }
  132.     if (OBJECT_TYPE (Obj_Address[1]) != PURE_PART)
  133.     {
  134.       printf ("Missing subsequent pure header.\n");
  135.     }
  136.     if (OBJECT_TYPE (Obj_Address[Pure_Size-1]) !=
  137.         TC_MANIFEST_SPECIAL_NM_VECTOR)
  138.     {
  139.       printf ("Missing internal SNMV.\n");
  140.       return;
  141.     }
  142.     if (OBJECT_TYPE (Obj_Address[Pure_Size]) != CONSTANT_PART)
  143.     {
  144.       printf ("Missing constant header.\n");
  145.       return;
  146.     }
  147.     if (OBJECT_DATUM (Obj_Address[Pure_Size]) != Pure_Size)
  148.     {
  149.       printf ("Pure size mismatch 0x%lx.\n",
  150.           ((long) (OBJECT_DATUM (Obj_Address[Pure_Size]))));
  151.     }
  152.     if (OBJECT_TYPE (Obj_Address[Total_Size-1]) !=
  153.         TC_MANIFEST_SPECIAL_NM_VECTOR)
  154.     {
  155.       printf ("Missing ending SNMV.\n");
  156.       return;
  157.     }
  158.     if (OBJECT_TYPE (Obj_Address[Total_Size]) != END_OF_BLOCK)
  159.     {
  160.       printf ("Missing ending header.\n");
  161.       return;
  162.     }
  163.     if (OBJECT_DATUM (Obj_Address[Total_Size]) != Total_Size)
  164.     {
  165.       printf ("Total size mismatch 0x%lx.\n",
  166.           ((long) (OBJECT_DATUM (Obj_Address[Total_Size]))));
  167.     }
  168.     Obj_Address += Total_Size+1;
  169. #ifdef FLOATING_ALIGNMENT
  170.     while (*Obj_Address == MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0))
  171.     {
  172.       Obj_Address += 1;
  173.     }
  174. #endif
  175.   }
  176. }
  177.  
  178. void
  179. DEFUN (Show_Env, (The_Env), SCHEME_OBJECT The_Env)
  180. {
  181.   SCHEME_OBJECT *name_ptr, procedure, *value_ptr, extension;
  182.   long count, i;
  183.  
  184.   procedure = MEMORY_REF (The_Env, ENVIRONMENT_FUNCTION);
  185.   value_ptr = MEMORY_LOC (The_Env, ENVIRONMENT_FIRST_ARG);
  186.  
  187.   if (OBJECT_TYPE (procedure) == AUX_LIST_TYPE)
  188.   {
  189.     extension = procedure;
  190.     procedure = FAST_MEMORY_REF (extension, ENV_EXTENSION_PROCEDURE);
  191.   }
  192.   else
  193.     extension = SHARP_F;
  194.  
  195.   if ((OBJECT_TYPE (procedure) != TC_PROCEDURE) &&
  196.       (OBJECT_TYPE (procedure) != TC_EXTENDED_PROCEDURE))
  197.   {
  198.     printf ("Not created by a procedure");
  199.     return;
  200.   }
  201.   name_ptr = MEMORY_LOC (procedure, PROCEDURE_LAMBDA_EXPR);
  202.   name_ptr = MEMORY_LOC (*name_ptr, LAMBDA_FORMALS);
  203.   count = VECTOR_LENGTH (*name_ptr) - 1;
  204.  
  205.   name_ptr = MEMORY_LOC (*name_ptr, 2);
  206.   for (i = 0; i < count; i++)
  207.   {
  208.     Print_Expression (*name_ptr++, "Name ");
  209.     Print_Expression (*value_ptr++, " Value ");
  210.     printf ("\n");
  211.   }
  212.   if (extension != SHARP_F)
  213.   {
  214.     printf ("Auxilliary Variables\n");
  215.     count = OBJECT_DATUM (MEMORY_REF (extension, AUX_LIST_COUNT));
  216.     for (i = 0, name_ptr = MEMORY_LOC (extension, AUX_LIST_FIRST);
  217.      i < count;
  218.      i++, name_ptr++)
  219.     {
  220.       Print_Expression ((PAIR_CAR (*name_ptr)), "Name ");
  221.       Print_Expression ((PAIR_CDR (*name_ptr)), " Value ");
  222.       printf ("\n");
  223.     }
  224.   }
  225. }
  226.  
  227. static void
  228. DEFUN (print_list, (stream, pair), FILE * stream AND SCHEME_OBJECT pair)
  229. {
  230.   int count;
  231.  
  232.   fprintf (stream, "(");
  233.   count = 0;
  234.   while (((PAIR_P (pair)) || (WEAK_PAIR_P (pair))) && (count < MAX_LIST_PRINT))
  235.     {
  236.       if (count > 0)
  237.     fprintf (stream, " ");
  238.       print_expression (stream,
  239.             (PAIR_CAR (pair)),
  240.             ((WEAK_PAIR_P (pair)) ? "{weak}" : ""));
  241.       pair = (PAIR_CDR (pair));
  242.       count += 1;
  243.     }
  244.   if (pair != EMPTY_LIST)
  245.     {
  246.       if (count == MAX_LIST_PRINT)
  247.     fprintf (stream, " ...");
  248.       else
  249.     {
  250.       fprintf (stream, " . ");
  251.       print_expression (stream, pair, "");
  252.     }
  253.     }
  254.   fprintf (stream, ")");
  255.   return;
  256. }
  257.  
  258. static void
  259. DEFUN (print_return_name, (stream, Ptr), FILE * stream AND SCHEME_OBJECT Ptr)
  260. {
  261.   long index;
  262.   char * name;
  263.  
  264.   index = (OBJECT_DATUM (Ptr));
  265.   if (index <= MAX_RETURN)
  266.     {
  267.       name = (Return_Names [index]);
  268.       if ((name != ((char *) 0)) &&
  269.       ((name [0]) != '\0'))
  270.     {
  271.       fprintf (stream, "%s", name);
  272.       return;
  273.     }
  274.     }
  275.   fprintf (stream, "[0x%lx]", index);
  276.   return;
  277. }
  278.  
  279. void
  280. DEFUN (Print_Return, (String), char * String)
  281. {
  282.   printf ("%s: ", String);
  283.   print_return_name (stdout, Fetch_Return ());
  284.   printf ("\n");
  285. }
  286.  
  287. static void
  288. DEFUN (print_string, (stream, string), FILE * stream AND SCHEME_OBJECT string)
  289. {
  290.   long length;
  291.   long i;
  292.   char * next;
  293.   char this;
  294.  
  295.   fprintf (stream, "\"");
  296.   length = (STRING_LENGTH (string));
  297.   next = ((char *) (STRING_LOC (string, 0)));
  298.   for (i = 0; (i < length); i += 1)
  299.     {
  300.       this = (*next++);
  301.       switch (this)
  302.     {
  303.     case '\\':
  304.       fprintf (stream, "\\\\");
  305.       break;
  306.     case '"':
  307.       fprintf (stream, "\\\"");
  308.       break;
  309.     case '\t':
  310.       fprintf (stream, "\\t");
  311.       break;
  312.     case '\n':
  313.       fprintf (stream, "\\n");
  314.       break;
  315.     case '\f':
  316.       fprintf (stream, "\\f");
  317.       break;
  318.     default:
  319.       if ((this >= ' ') && (this <= '~'))
  320.         putc (this, stream);
  321.       else
  322.         fprintf (stream, "\\%03o", this);
  323.       break;
  324.     }
  325.     }
  326.   fprintf (stream, "\"");
  327.   return;
  328. }
  329.  
  330. static void
  331. DEFUN (print_symbol, (stream, symbol), FILE * stream AND SCHEME_OBJECT symbol)
  332. {
  333.   SCHEME_OBJECT string;
  334.   long length;
  335.   long i;
  336.   char * next;
  337.  
  338.   string = (MEMORY_REF (symbol, SYMBOL_NAME));
  339.   length = (STRING_LENGTH (string));
  340.   next = ((char *) (STRING_LOC (string, 0)));
  341.   for (i = 0; (i < length); i += 1)
  342.     putc (*next++, stream);
  343.   return;
  344. }
  345.  
  346. static void
  347. DEFUN (print_filename, (stream, filename),
  348.        FILE * stream AND SCHEME_OBJECT filename)
  349. {
  350.   long length;
  351.   char * scan;
  352.   char * end;
  353.   char * slash;
  354.  
  355.   length = (STRING_LENGTH (filename));
  356.   scan = ((char *) (STRING_LOC (filename, 0)));
  357.   end = (scan + length);
  358.   slash = scan;
  359.   while (scan < end)
  360.     if ((*scan++) == '/')
  361.       slash = scan;
  362.   fprintf (stream, "\"%s\"", slash);
  363.   return;
  364. }
  365.  
  366. static void
  367. DEFUN (print_object, (object), SCHEME_OBJECT object)
  368. {
  369.   do_printing (stdout, object, true);
  370.   printf ("\n");
  371.   fflush (stdout);
  372.   return;
  373. }
  374.  
  375. DEFINE_PRIMITIVE ("DEBUGGING-PRINTER", Prim_debugging_printer, 1, 1,
  376.   "A cheap, built-in printer intended for debugging the interpreter.")
  377. {
  378.   PRIMITIVE_HEADER (1);
  379.  
  380.   print_object (ARG_REF (1));
  381.   return (SHARP_F);
  382. }
  383.  
  384. static void
  385. DEFUN (print_objects, (objects, n),
  386.        SCHEME_OBJECT * objects AND int n)
  387. {
  388.   SCHEME_OBJECT * scan;
  389.   SCHEME_OBJECT * end;
  390.  
  391.   scan = objects;
  392.   end = (objects + n);
  393.   while (scan < end)
  394.     {
  395.       printf ("%4x: ", (((char *) scan) - ((char *) objects)));
  396.       do_printing (stdout, (*scan++), true);
  397.       printf ("\n");
  398.     }
  399.   fflush (stdout);
  400.   return;
  401. }
  402.  
  403. /* This is useful because `do_printing' doesn't print the contents of
  404.    vectors.  The reason that it doesn't is because vectors are used to
  405.    represent named structures, and most named structures don't want to
  406.    be printed out explicitly.  */
  407.  
  408. static void
  409. DEFUN (print_vector, (vector), SCHEME_OBJECT vector)
  410. {
  411.   print_objects
  412.     ((MEMORY_LOC (vector, 1)), (OBJECT_DATUM (VECTOR_LENGTH (vector))));
  413.   return;
  414. }
  415.  
  416. static void
  417. DEFUN (print_expression, (stream, expression, string),
  418.        FILE * stream AND SCHEME_OBJECT expression AND char * string)
  419. {
  420.   if ((string [0]) != 0)
  421.     fprintf (stream, "%s: ", string);
  422.   do_printing (stream, expression, true);
  423.   return;
  424. }
  425.  
  426. void
  427. DEFUN (Print_Expression, (expression, string),
  428.        SCHEME_OBJECT expression AND char * string)
  429. {
  430.   print_expression (stdout, expression, string);
  431.   return;
  432. }
  433.  
  434. extern char * Type_Names [];
  435.  
  436. static void
  437. DEFUN (do_printing, (stream, Expr, Detailed),
  438.        FILE * stream AND SCHEME_OBJECT Expr AND Boolean Detailed)
  439. {
  440.   long Temp_Address;
  441.   Boolean handled_p;
  442.  
  443.   Temp_Address = (OBJECT_DATUM (Expr));
  444.   handled_p = false;
  445.  
  446.   switch (OBJECT_TYPE (Expr))
  447.     {
  448.     case TC_ACCESS:
  449.       {
  450.     fprintf (stream, "[ACCESS (");
  451.     Expr = (MEMORY_REF (Expr, ACCESS_NAME));
  452.       SPrint:
  453.     print_symbol (stream, Expr);
  454.     handled_p = true;
  455.     fprintf (stream, ")");
  456.     break;
  457.       }
  458.  
  459.     case TC_ASSIGNMENT:
  460.       fprintf (stream, "[SET! (");
  461.       Expr = (MEMORY_REF ((MEMORY_REF (Expr, ASSIGN_NAME)), VARIABLE_SYMBOL));
  462.       goto SPrint;
  463.  
  464.     case TC_CHARACTER_STRING:
  465.       print_string (stream, Expr);
  466.       return;
  467.  
  468.     case TC_DEFINITION:
  469.       fprintf (stream, "[DEFINE (");
  470.       Expr = (MEMORY_REF (Expr, DEFINE_NAME));
  471.       goto SPrint;
  472.  
  473.     case TC_FIXNUM:
  474.       fprintf (stream, "%ld", ((long) (FIXNUM_TO_LONG (Expr))));
  475.       return;
  476.  
  477.     case TC_BIG_FLONUM:
  478.       fprintf (stream, "%lf", (FLONUM_TO_DOUBLE (Expr)));
  479.       return;
  480.  
  481.     case TC_WEAK_CONS:
  482.     case TC_LIST:
  483.       print_list (stream, Expr);
  484.       return;
  485.  
  486.     case TC_NULL:
  487.       if (Temp_Address == 0)
  488.     {
  489.       fprintf (stream, "()");
  490.       return;
  491.     }
  492.       break;
  493.  
  494.     case TC_UNINTERNED_SYMBOL:
  495.       fprintf (stream, "[UNINTERNED_SYMBOL (");
  496.       goto SPrint;
  497.  
  498.     case TC_INTERNED_SYMBOL:
  499.       print_symbol (stream, Expr);
  500.       return;
  501.  
  502.     case TC_VARIABLE:
  503.       Expr = (MEMORY_REF (Expr, VARIABLE_SYMBOL));
  504.       if (Detailed)
  505.     {
  506.       fprintf (stream, "[VARIABLE (");
  507.       goto SPrint;
  508.     }
  509.       print_symbol (stream, Expr);
  510.       return;
  511.  
  512.     case TC_COMBINATION:
  513.       fprintf (stream, "[COMBINATION (%ld args) 0x%lx]",
  514.           ((long) ((VECTOR_LENGTH (Expr)) - 1)),
  515.           ((long) Temp_Address));
  516.       if (Detailed)
  517.     {
  518.       fprintf (stream, " (");
  519.       do_printing (stream, (MEMORY_REF (Expr, COMB_FN_SLOT)), false);
  520.       fprintf (stream, " ...)");
  521.     }
  522.       return;
  523.  
  524.     case TC_COMBINATION_1:
  525.       fprintf (stream, "[COMBINATION_1 0x%lx]", ((long) Temp_Address));
  526.       if (Detailed)
  527.     {
  528.       fprintf (stream, " (");
  529.       do_printing (stream, (MEMORY_REF (Expr, COMB_1_FN)), false);
  530.       fprintf (stream, ", ");
  531.       do_printing (stream, (MEMORY_REF (Expr, COMB_1_ARG_1)), false);
  532.       fprintf (stream, ")");
  533.     }
  534.       return;
  535.  
  536.     case TC_COMBINATION_2:
  537.       fprintf (stream, "[COMBINATION_2 0x%lx]", ((long) Temp_Address));
  538.       if (Detailed)
  539.     {
  540.       fprintf (stream, " (");
  541.       do_printing (stream, (MEMORY_REF (Expr, COMB_2_FN)), false);
  542.       fprintf (stream, ", ");
  543.       do_printing (stream, (MEMORY_REF (Expr, COMB_2_ARG_1)), false);
  544.       fprintf (stream, ", ");
  545.       do_printing (stream, (MEMORY_REF (Expr, COMB_2_ARG_2)), false);
  546.       fprintf (stream, ")");
  547.     }
  548.       return;
  549.  
  550.     case TC_ENVIRONMENT:
  551.       {
  552.     SCHEME_OBJECT procedure;
  553.  
  554.     fprintf (stream, "[ENVIRONMENT 0x%lx]", ((long) Temp_Address));
  555.     fprintf (stream, " (from ");
  556.     procedure = (MEMORY_REF (Expr, ENVIRONMENT_FUNCTION));
  557.     if ((OBJECT_TYPE (procedure)) == TC_QUAD)
  558.       procedure = (MEMORY_REF (procedure, ENV_EXTENSION_PROCEDURE));
  559.     do_printing (stream, procedure, false);
  560.     fprintf (stream, ")");
  561.     return;
  562.       }
  563.  
  564.     case TC_EXTENDED_LAMBDA:
  565.       if (Detailed)
  566.     fprintf (stream, "[EXTENDED_LAMBDA (");
  567.       do_printing (stream,
  568.            (MEMORY_REF ((MEMORY_REF (Expr, ELAMBDA_NAMES)), 1)),
  569.            false);
  570.       if (Detailed)
  571.     fprintf (stream, ") 0x%lx", ((long) Temp_Address));
  572.       return;
  573.  
  574.     case TC_EXTENDED_PROCEDURE:
  575.       if (Detailed)
  576.     fprintf (stream, "[EXTENDED_PROCEDURE (");
  577.       do_printing (stream, (MEMORY_REF (Expr, PROCEDURE_LAMBDA_EXPR)), false);
  578.       if (Detailed)
  579.     fprintf (stream, ") 0x%lx]", ((long) Temp_Address));
  580.       break;
  581.  
  582.     case TC_LAMBDA:
  583.       if (Detailed)
  584.     fprintf (stream, "[LAMBDA (");
  585.       do_printing (stream,
  586.            (MEMORY_REF ((MEMORY_REF (Expr, LAMBDA_FORMALS)), 1)),
  587.           false);
  588.       if (Detailed)
  589.     fprintf (stream, ") 0x%lx]", ((long) Temp_Address));
  590.       return;
  591.  
  592.     case TC_PRIMITIVE:
  593.       fprintf (stream, "[PRIMITIVE ");
  594.       print_primitive_name (stream, Expr);
  595.       fprintf (stream, "]");
  596.       return;
  597.  
  598.     case TC_PROCEDURE:
  599.       if (Detailed)
  600.     fprintf (stream, "[PROCEDURE (");
  601.       do_printing (stream, (MEMORY_REF (Expr, PROCEDURE_LAMBDA_EXPR)), false);
  602.       if (Detailed)
  603.     fprintf (stream, ") 0x%lx]", ((long) Temp_Address));
  604.       return;
  605.  
  606.     case TC_REFERENCE_TRAP:
  607.       {
  608.     if ((OBJECT_DATUM (Expr)) <= TRAP_MAX_IMMEDIATE)
  609.       break;
  610.     fprintf (stream, "[REFERENCE-TRAP");
  611.     print_expression (stream, (MEMORY_REF (Expr, TRAP_TAG)), " tag");
  612.     print_expression (stream, (MEMORY_REF (Expr, TRAP_EXTRA)), " extra");
  613.     fprintf (stream, "]");
  614.     return;
  615.       }
  616.  
  617.     case TC_RETURN_CODE:
  618.       fprintf (stream, "[RETURN_CODE ");
  619.       print_return_name (stream, Expr);
  620.       fprintf (stream, "]");
  621.       return;
  622.  
  623.     case TC_TRUE:
  624.       if (Temp_Address == 0)
  625.     {
  626.       fprintf (stream, "#T");
  627.       return;
  628.     }
  629.       break;
  630.  
  631.     case TC_COMPILED_ENTRY:
  632.       {
  633.     long results [3];
  634.     char * type_string;
  635.     SCHEME_OBJECT filename;
  636.     SCHEME_OBJECT entry;
  637.     Boolean closure_p;
  638.  
  639.     entry = Expr;
  640.     closure_p = false;
  641.     compiled_entry_type (entry, (& (results [0])));
  642.     switch (results [0])
  643.       {
  644.       case 0:
  645.         if (compiled_entry_closure_p (entry))
  646.           {
  647.         type_string = "COMPILED_CLOSURE";
  648.         entry = (compiled_closure_to_entry (entry));
  649.         closure_p = true;
  650.           }
  651.         else
  652.           type_string = "COMPILED_PROCEDURE";
  653.         break;
  654.       case 1:
  655.         type_string = "COMPILED_RETURN_ADDRESS";
  656.         break;
  657.       case 2:
  658.         type_string = "COMPILED_EXPRESSION";
  659.         break;
  660.       default:
  661.         type_string = "COMPILED_ENTRY";
  662.         break;
  663.       }
  664.  
  665.     fprintf (stream, "[%s offset: 0x%lx entry: 0x%lx",
  666.          type_string,
  667.          ((long) (compiled_entry_to_block_offset (entry))),
  668.          ((long) (OBJECT_DATUM (entry))));
  669.     if (closure_p)
  670.       fprintf (stream, " address: 0x%lx", ((long) Temp_Address));
  671.  
  672.     filename = (compiled_entry_debug_filename (entry));
  673.     if (STRING_P (filename))
  674.       {
  675.         fprintf (stream, " file: ");
  676.         print_filename (stream, filename);
  677.       }
  678.     else if (PAIR_P (filename))
  679.       {
  680.         fprintf (stream, " file: ");
  681.         print_filename (stream, (PAIR_CAR (filename)));
  682.         fprintf (stream, " block: %ld",
  683.             ((long) (FIXNUM_TO_LONG (PAIR_CDR (filename)))));
  684.       }
  685.     fprintf (stream, "]");
  686.     return;
  687.       }
  688.  
  689.     default:
  690.       break;
  691.     }
  692.   if (! handled_p)
  693.     {
  694.       if ((OBJECT_TYPE (Expr)) <= LAST_TYPE_CODE)
  695.     fprintf (stream, "[%s", (Type_Names [OBJECT_TYPE (Expr)]));
  696.       else
  697.     fprintf (stream, "[0x%02x", (OBJECT_TYPE (Expr)));
  698.     }
  699.   fprintf (stream, " 0x%lx]", ((long) Temp_Address));
  700.   return;
  701. }
  702.  
  703. static Boolean
  704. DEFUN (print_one_continuation_frame, (stream, Temp),
  705.        FILE * stream AND SCHEME_OBJECT Temp)
  706. {
  707.   SCHEME_OBJECT Expr;
  708.  
  709.   print_expression (stream, Temp, "Return code");
  710.   fprintf (stream, "\n");
  711.   Expr = (STACK_POP ());
  712.   print_expression (stream, Expr, "Expression");
  713.   fprintf (stream, "\n");
  714.   if (((OBJECT_DATUM (Temp)) == RC_END_OF_COMPUTATION) ||
  715.       ((OBJECT_DATUM (Temp)) == RC_HALT))
  716.     return (true);
  717.   if ((OBJECT_DATUM (Temp)) == RC_JOIN_STACKLETS)
  718.     Stack_Pointer = (Previous_Stack_Pointer (Expr));
  719.   return (false);
  720. }
  721.  
  722. extern Boolean EXFUN (Print_One_Continuation_Frame, (SCHEME_OBJECT));
  723.  
  724. Boolean
  725. DEFUN (Print_One_Continuation_Frame, (Temp), SCHEME_OBJECT Temp)
  726. {
  727.   return (print_one_continuation_frame (stdout, Temp));
  728. }
  729.  
  730. /* Back_Trace relies on (a) only a call to Save_Cont puts a return code on the
  731.    stack; (b) Save_Cont pushes the expression first.
  732.  */
  733.  
  734. void
  735. DEFUN (Back_Trace, (stream), FILE * stream)
  736. {
  737.   SCHEME_OBJECT Temp, * Old_Stack;
  738.  
  739.   Back_Trace_Entry_Hook();
  740.   Old_Stack = Stack_Pointer;
  741.   while (true)
  742.   {
  743.     if ((STACK_LOCATIVE_DIFFERENCE (Stack_Top, (STACK_LOC (0)))) <= 0)
  744.     {
  745.       if ((STACK_LOC (0)) == Old_Stack)
  746.     fprintf (stream, "\n[Invalid stack pointer.]\n");
  747.       else
  748.     fprintf (stream, "\n[Stack ends abruptly.]\n");
  749.       break;
  750.     }
  751.     if (Return_Hook_Address == (STACK_LOC (0)))
  752.     {
  753.       Temp = (STACK_POP ());
  754.       if (Temp != (MAKE_OBJECT (TC_RETURN_CODE, RC_RETURN_TRAP_POINT)))
  755.       {
  756.         fprintf (stream, "\n--> Return trap is missing here <--\n");
  757.       }
  758.       else
  759.       {
  760.     fprintf (stream, "\n[Return trap found here as expected]\n");
  761.         Temp = Old_Return_Code;
  762.       }
  763.     }
  764.     else
  765.     {
  766.       Temp = (STACK_POP ());
  767.     }
  768.     if ((OBJECT_TYPE (Temp)) == TC_RETURN_CODE)
  769.     {
  770.       if (print_one_continuation_frame (stream, Temp))
  771.     break;
  772.     }
  773.     else
  774.     {
  775.       print_expression (stream, Temp, "  ...");
  776.       if ((OBJECT_TYPE (Temp)) == TC_MANIFEST_NM_VECTOR)
  777.       {
  778.     Stack_Pointer = (STACK_LOC (- (OBJECT_DATUM (Temp))));
  779.         fprintf (stream, " (skipping)");
  780.       }
  781.       fprintf (stream, "\n");
  782.     }
  783.   }
  784.   Stack_Pointer = Old_Stack;
  785.   Back_Trace_Exit_Hook();
  786.   fflush (stream);
  787.   return;
  788. }
  789.  
  790. static void
  791. DEFUN (print_stack, (sp), SCHEME_OBJECT * sp)
  792. {
  793.   SCHEME_OBJECT * saved_sp;
  794.  
  795.   saved_sp = Stack_Pointer;
  796.   Stack_Pointer = sp;
  797.   Back_Trace (stdout);
  798.   Stack_Pointer = saved_sp;
  799.   return;
  800. }
  801.  
  802. static Boolean
  803. DEFUN (print_primitive_name, (stream, primitive),
  804.        FILE * stream AND SCHEME_OBJECT primitive)
  805. {
  806.   extern char * EXFUN (primitive_to_name, (SCHEME_OBJECT));
  807.   char *name;
  808.  
  809.   name = primitive_to_name(primitive);
  810.   if (name == ((char *) NULL))
  811.   {
  812.     fprintf (stream, "Unknown primitive 0x%08x", PRIMITIVE_NUMBER(primitive));
  813.     return false;
  814.   }
  815.   else
  816.   {
  817.     fprintf (stream, "%s", name);
  818.     return true;
  819.   }
  820. }
  821.  
  822. void
  823. DEFUN (Print_Primitive, (primitive), SCHEME_OBJECT primitive)
  824. {
  825.   extern long EXFUN (primitive_to_arity, (SCHEME_OBJECT));
  826.   char buffer[40];
  827.   int NArgs, i;
  828.  
  829.   printf ("Primitive: ");
  830.   if (print_primitive_name (stdout, primitive))
  831.   {
  832.     NArgs = primitive_to_arity(primitive);
  833.   }
  834.   else
  835.   {
  836.     NArgs = 3;            /* Unknown primitive */
  837.   }
  838.   printf ("\n");
  839.  
  840.   for (i = 0; i < NArgs; i++)
  841.   {
  842.     sprintf (buffer, "...Arg %ld", ((long) (i + 1)));
  843.     print_expression (stdout, (STACK_REF (i)), buffer);
  844.     printf ("\n");
  845.   }
  846.   return;
  847. }
  848.  
  849. /* Code for interactively setting and clearing the interpreter
  850.    debugging flags.  Invoked via the "D" command to the ^C
  851.    handler or during each FASLOAD. */
  852.  
  853. #ifdef ENABLE_DEBUGGING_TOOLS
  854.  
  855. #ifndef MORE_DEBUG_FLAG_CASES
  856. #define MORE_DEBUG_FLAG_CASES()
  857. #endif
  858.  
  859. #ifndef MORE_DEBUG_FLAG_NAMES
  860. #define MORE_DEBUG_FLAG_NAMES()
  861. #endif
  862.  
  863. #ifndef SET_FLAG_HOOK
  864. #define SET_FLAG_HOOK()
  865. #endif
  866.  
  867. #ifndef DEBUG_GETDEC
  868. #define DEBUG_GETDEC debug_getdec
  869. #endif
  870.  
  871. #define D_EVAL            0
  872. #define D_HEX_INPUT        1
  873. #define D_FILE_LOAD        2
  874. #define D_RELOC            3
  875. #define D_INTERN        4
  876. #define D_CONT            5
  877. #define D_PRIMITIVE        6
  878. #define D_LOOKUP        7
  879. #define D_DEFINE        8
  880. #define D_GC            9
  881. #define D_UPGRADE        10
  882. #define D_DUMP            11
  883. #define D_TRACE_ON_ERROR    12
  884. #define D_PER_FILE        13
  885. #define D_BIGNUM        14
  886. #define D_FLUIDS        15
  887.  
  888. #ifndef LAST_SWITCH
  889. #define LAST_SWITCH D_FLUIDS
  890. #endif
  891.  
  892. static Boolean *
  893. DEFUN (find_flag, (flag_number), int flag_number)
  894. {
  895.   switch (flag_number)
  896.     {
  897.     case D_EVAL:        return (&Eval_Debug);
  898.     case D_HEX_INPUT:        return (&Hex_Input_Debug);
  899.     case D_FILE_LOAD:        return (&File_Load_Debug);
  900.     case D_RELOC:        return (&Reloc_Debug);
  901.     case D_INTERN:        return (&Intern_Debug);
  902.     case D_CONT:        return (&Cont_Debug);
  903.     case D_PRIMITIVE:        return (&Primitive_Debug);
  904.     case D_LOOKUP:        return (&Lookup_Debug) ;
  905.     case D_DEFINE:        return (&Define_Debug);
  906.     case D_GC:            return (&GC_Debug);
  907.     case D_UPGRADE:        return (&Upgrade_Debug);
  908.     case D_DUMP:        return (&Dump_Debug);
  909.     case D_TRACE_ON_ERROR:    return (&Trace_On_Error);
  910.     case D_PER_FILE:        return (&Per_File);
  911.     case D_BIGNUM:        return (&Bignum_Debug);
  912.     case D_FLUIDS:        return (&Fluids_Debug);
  913.     MORE_DEBUG_FLAG_CASES ();
  914.     default:            return (0);
  915.     }
  916. }
  917.  
  918. static char *
  919. DEFUN (flag_name, (flag_number), int flag_number)
  920. {
  921.   switch (flag_number)
  922.     {
  923.     case D_EVAL:        return ("Eval_Debug");
  924.     case D_HEX_INPUT:        return ("Hex_Input_Debug");
  925.     case D_FILE_LOAD:        return ("File_Load_Debug");
  926.     case D_RELOC:        return ("Reloc_Debug");
  927.     case D_INTERN:        return ("Intern_Debug");
  928.     case D_CONT:        return ("Cont_Debug");
  929.     case D_PRIMITIVE:        return ("Primitive_Debug");
  930.     case D_LOOKUP:        return ("Lookup_Debug");
  931.     case D_DEFINE:        return ("Define_Debug");
  932.     case D_GC:            return ("GC_Debug");
  933.     case D_UPGRADE:        return ("Upgrade_Debug");
  934.     case D_DUMP:        return ("Dump_Debug");
  935.     case D_TRACE_ON_ERROR:    return ("Trace_On_Error");
  936.     case D_PER_FILE:        return ("Per_File");
  937.     case D_BIGNUM:        return ("Bignum_Debug");
  938.     case D_FLUIDS:        return ("Fluids_Debug");
  939.     MORE_DEBUG_FLAG_NAMES ();
  940.     default:            return ("Unknown Debug Flag");
  941.     }
  942. }
  943.  
  944. static void
  945. DEFUN (show_flags, (all), int all)
  946. {
  947.   int i;
  948.   for (i = 0; (i <= LAST_SWITCH); i += 1)
  949.     {
  950.       int value = (* (find_flag (i)));
  951.       if (all || value)
  952.     fprintf (stdout, "Flag %ld (%s) is %s.\n",
  953.          ((long) i), (flag_name (i)), (value ? "set" : "clear"));
  954.     }
  955.   fflush (stdout);
  956.   return;
  957. }
  958.  
  959. static int
  960. DEFUN (set_flag, (flag_number, value), int flag_number AND int value)
  961. {
  962.   Boolean * flag = (find_flag (flag_number));
  963.   if (flag == 0)
  964.     show_flags (1);
  965.   else
  966.     {
  967.       (*flag) = value;
  968.       SET_FLAG_HOOK (flag);
  969.     }
  970.   return (0);
  971. }
  972.  
  973. static int
  974. DEFUN (debug_getdec, (string), CONST char * string)
  975. {
  976.   int result;
  977.  
  978.   sscanf (string, "%ld", (&result));
  979.   return (result);
  980. }
  981.  
  982. void
  983. DEFUN_VOID (debug_edit_flags)
  984. {
  985.   char input_line [256];
  986.   show_flags (0);
  987.   while (1)
  988.     {
  989.       fputs ("Clear<number>, Set<number>, Done, ?, or Halt: ", stdout);
  990.       fflush (stdout);
  991.       {
  992.     fgets (input_line, (sizeof (input_line)), stdin);
  993.     switch (input_line[0])
  994.       {
  995.        case 'c':
  996.        case 'C':
  997.          set_flag ((DEBUG_GETDEC (input_line)), 0);
  998.          break;
  999.        case 's':
  1000.        case 'S':
  1001.          set_flag ((DEBUG_GETDEC (input_line)), 1);
  1002.          break;
  1003.        case 'd':
  1004.        case 'D':
  1005.          return;
  1006.        case 'h':
  1007.        case 'H':
  1008.          termination_normal (0);
  1009.        case '?':
  1010.        default:
  1011.          show_flags (1);
  1012.          break;
  1013.        }
  1014.       }
  1015.     }
  1016. }
  1017.  
  1018. #else /* not ENABLE_DEBUGGING_TOOLS */
  1019.  
  1020. void
  1021. DEFUN_VOID (debug_edit_flags)
  1022. {
  1023.   fprintf (stderr, "Not a debugging version.  No flags to handle.\n");
  1024.   fflush (stderr);
  1025.   return;
  1026. }
  1027.  
  1028. #endif /* not ENABLE_DEBUGGING_TOOLS */
  1029.